home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / gen.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  25KB  |  1,049 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #define GEN
  10.  
  11. #include "hdr.h"
  12. #include "vars.h"
  13. #include "gvars.h"
  14. #include "ops.h"
  15. #include "segment.h"
  16. #include "slot.h"
  17. #include "attr.h"
  18. #include "genop.h"
  19. #include "opdescp.h"
  20. #include "segmentp.h"
  21. #include "gpredefp.h"
  22. #include "peepp.h"
  23. #include "setp.h"
  24. #include "miscp.h"
  25. #include "gmiscp.h"
  26. #include "smiscp.h"
  27. #include "genp.h"
  28.  
  29. static void gen_kfc(int, int, long, char *);
  30. static void gen_krc(int, int, float, char *);
  31. static void gen_r(int, Explicit_ref);
  32. static void gop_int(int, int, int, int, char *);
  33. static void gop_fix(int, int, int, long, char *);
  34. static void gop_flt(int, int, int, float, char *);
  35. static void gop_ref(int, int, int, Explicit_ref, char *);
  36. static void gop_sym(int, int, int, Symbol, char *);
  37. #ifdef DEBUG
  38. static void undone_op(int, char *);
  39. #endif
  40. static char *g_kind(int);
  41. static int adjust(int);
  42. static int int_adjust(int);
  43. static int fix_adjust(int);
  44. static int float_adjust(int);
  45. static void pretty_addr(int);
  46. static void asm_exception(Symbol);
  47. static void asm_byte(int);
  48. static void asm_int(int);
  49. static void asm_fix(long);
  50. static void asm_flt(float);
  51. static void asm_seg(int);
  52. static void asm_off(int);
  53. static void G_int(int);
  54. static void G_fix(long);
  55. static void G_flt(float);
  56. #ifdef DEBUG
  57. static void zpop(Op);
  58. #endif
  59. static void gref_sort(Tuple, int);
  60. static int gref_compare_name(Gref *, Gref *);
  61. static int gref_compare_address(Gref *, Gref *);
  62. static char *gs_end();
  63.  
  64. extern Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  65.  
  66. /*
  67.  2-jun
  68.  note that calls to gen(I_DISCARD_ADDR, n, ..) always have 1 as the
  69.  second argument. This is kept in 'kind' field. The third argument
  70.  is not always present, in which case (Symbol)0 should be written.
  71.  
  72.  5-jul    ds
  73.  Translated the two calls to gen(I_CASE_TABLE ...) in stat.c as
  74.  gen_ks.
  75.  ---
  76.  Translate the calls for gen(I_ATTRIBUTE, ...) to the form
  77.  gen_kv(...) using (Const) 0 for third arg in cases where SETL
  78.  has only two args.
  79.  
  80.  
  81.  15-jul    ds
  82.  Note following from mail note from Rosen:
  83. The integer value is the numb of addresses to discard. It is normally one,
  84. but the peep-hole optimizer may merge severall consecutives discard_addr
  85. into one.
  86.  
  87. Note that the symbol name is given in the COMMENT field (and may thus be
  88. omitted). If present, it is used by the peep-hole optimizer to trap things
  89. like:
  90. discard_addr 1 --symbol
  91. push_addr symbol
  92.  
  93. */
  94.  
  95. static char G_s[256]; /* for trace output of instructions */
  96. /* macro to position at end of G_s */
  97. char *gs_end();
  98. #define G_END gs_end()
  99.  
  100. /* create dummy entry for p (np is string with name of p)
  101.  * and call chaos if p is called
  102.  * Current operand types:
  103.  *    gen_i    integer
  104.  *     gen_k    kind (from kind_of, offset added to opcode to get
  105.  *        final opcode) this field is also used for integer
  106.  *        for i_discard_address (always 1) and for attribute
  107.  *        code (<= 50) for I_ATTRIBUTE.
  108.  *    gen_kc
  109.  *    gen_ki
  110.  *    gen_kic
  111.  *    gen_ks    kind and symbol
  112.  *    gen_ksc
  113.  *    gen_kv    kind and value (Const), used mainly for push_immediate
  114.  *        instructions. The v argument must be Const.
  115.  *    gen_kvc
  116.  *    gen_r    explicit reference (two args: segment and offset)
  117.  *        in this case segment and offset always zero!!
  118.  *    gen_rc
  119.  *    gen_s    symbol
  120.  *    gen_sc
  121.  */
  122.  
  123. struct Op_s op_next;
  124.  
  125. /* set values in global variable op_next, needed copying done by assemble */
  126. #define gop_new(opc, k, ka, c)    op_next.op_code = opc; op_next.op_kind = k;\
  127.     op_next.op_type  = ka; op_next.op_com = c; 
  128.  
  129. #ifdef DEBUG
  130. #define undone(p, np) p(op) int op; { undone_op(op, np);}
  131. #endif
  132.  
  133. void gen(int opc)                                            /*;gen*/
  134. {
  135.     gop_int(opc, 0, 0, 0, (char *)0);
  136. }
  137.  
  138. void gen_c(int opc, char *c)                                /*;gen_c*/
  139. {
  140.     gop_int(opc, 0, 0, 0, c);
  141. }
  142.  
  143. void gen_i(int opc, int i)                                    /*;gen_i*/
  144. {
  145.     gen_ic(opc, i, (char *)0);
  146. }
  147.  
  148. void gen_ic(int opc, int i, char *c)                            /*;gen_ic*/
  149. {
  150.     gop_int(opc, 0, OP_INT, i, c);
  151. }
  152.  
  153. void gen_k(int opc, int k)                                        /*;gen_k*/
  154. {
  155.     gen_kc(opc, k, (char *)0);
  156. }
  157.  
  158. void gen_kc(int opc, int k, char *c)                            /*;gen_k*/
  159. {
  160.     gop_int(opc, k, OP_INT, 0, c);
  161. }
  162.  
  163. void gen_ki(int opc, int k, int n)                                /*;gen_ki*/
  164. {
  165.     gen_kic(opc, k, n, (char *)0);
  166. }
  167.  
  168. void gen_kic(int opc, int k, int n, char *c)                    /*;gen_kic*/
  169. {
  170.     gop_int(opc, k, OP_INT, n, c);
  171. }
  172.  
  173. static void gen_kfc(int opc, int k, long n, char *c)                /*;gen_kfc*/
  174. {
  175.     gop_fix(opc, k, OP_FIX, n, c);
  176. }
  177.  
  178. static void gen_krc(int opc, int k, float n, char *c)            /*;gen_krc*/
  179. {
  180.     gop_flt(opc, k, OP_FLT, n, c);
  181. }
  182.  
  183. void gen_ks(int opc, int k, Symbol sym)                            /*;gen_ks*/
  184. {
  185.     gen_ksc(opc, k, sym, (char *)0);
  186. }
  187.  
  188. void gen_ksc(int opc, int k, Symbol sym, char *c)                /*;gen_ksc*/
  189. {
  190.     /* Note that I_DISCARD_ADDR has symbol supplied only for use
  191.      * by peephole optimizer. Since this is disable for now,
  192.      * ignore the symbol arg for this operation.
  193.      */
  194.     if (opc == I_DISCARD_ADDR)
  195.         gen_kic(opc, k, k, c);
  196.     else
  197.         gop_sym(opc, k, OP_SYM, sym, (char *)c);
  198. }
  199.  
  200. void gen_kv(int opc, int k, Const ref)                            /*;gen_kv*/
  201. {
  202.     gen_kvc(opc, k,  ref, (char *)0);
  203. }
  204.  
  205. void gen_kvc(int opc, int k, Const ref, char *c)                    /*;gen_kvc*/
  206. {
  207.     /* Need to get value from Const and see if length compatible with
  208.      * k argument
  209.      * Suppress check for now, just handle int's and longs, and
  210.      * also assume longs same size as ints
  211.      * TBSL: need to add checks, handle other const types, handle
  212.      * longs differently for PC        ds 7-15-85
  213.      */
  214.  
  215.     int ctype;
  216.  
  217.     ctype = ref->const_kind;
  218.     if (ctype == CONST_INT) {
  219.         gen_kic(opc, k, INTV(ref), c);
  220.     }
  221.     else if (ctype == CONST_FIXED) {
  222.         gen_kfc(opc, k, FIXEDV(ref), c);
  223.     }
  224.     else if (ctype == CONST_REAL) {
  225.         /* Note that treating ada reals as C reals here */
  226.         gen_krc(opc, k, REALV(ref), c);
  227.     }
  228.     else {
  229.         chaos("gop const undefined case");
  230.     }
  231. }
  232.  
  233. static void gen_r(int opc, Explicit_ref ref)                        /*;gen_r*/
  234. {
  235.     gen_rc(opc, ref, (char *)0);
  236. }
  237.  
  238. void gen_rc(int opc, Explicit_ref ref, char *c)                    /*;gen_rc*/
  239. {
  240.     gop_ref(opc, 0, OP_REF, ref, c);
  241. }
  242.  
  243. void gen_s(int opc, Symbol s)                                    /*;gen_s*/
  244. {
  245.     gen_sc(opc, s, (char *)0);
  246. }
  247.  
  248. void gen_sc(int opc, Symbol s, char *c)                                /*;gen_sc*/
  249. {
  250.     gop_sym(opc, 0, OP_SYM, s, c);
  251. }
  252.  
  253. static void gop_int(int opc, int k, int ka, int arg, char *c)        /*;gop_int*/
  254. {
  255.     gop_new(opc, k, ka, c);
  256.     op_next.op_arg.arg_int = arg;
  257.     peep_hole(&op_next);
  258. }
  259.  
  260. static void gop_fix(int opc, int k, int ka, long arg, char *c)        /*;gop_fix*/
  261. {
  262.     gop_new(opc, k, ka, c);
  263.     op_next.op_arg.arg_fix = arg;
  264.     peep_hole(&op_next);
  265. }
  266.  
  267. static void gop_flt(int opc, int k, int ka, float arg, char *c)        /*;gop_flt*/
  268. {
  269.     gop_new(opc, k, ka, c);
  270.     op_next.op_arg.arg_flt = arg;
  271.     peep_hole(&op_next);
  272. }
  273.  
  274. static void gop_ref(int opc, int k, int ka, Explicit_ref arg, char *c)
  275.                                                                 /*;gop_ref*/
  276. {
  277.     gop_new(opc, k, ka, c);
  278.     op_next.op_arg.arg_ref = arg;
  279.     peep_hole(&op_next);
  280. }
  281.  
  282. static void gop_sym(int opc, int k, int ka, Symbol arg, char *c)    /*;gop_sym*/
  283. {
  284.     gop_new(opc, k, ka, c);
  285.     op_next.op_arg.arg_sym = arg;
  286.     peep_hole(&op_next);
  287. }
  288.  
  289. #ifdef DEBUG
  290. static void undone_op(int op, char *np)                        /*;undone_op*/
  291. {
  292.     /* print name of generation procedure and name of operation */
  293.     extern char *opdesc_name;
  294.     opdesc(op);
  295.     printf("op %s %s\n", np, opdesc_name);
  296. }
  297. #endif
  298.  
  299. void assemble(Op op)                                        /*;assemble*/
  300. {
  301.     int    code;
  302.     Symbol    lab_name, new_lab, obj_name;
  303.     extern    char *opdesc_name;
  304.     int    data_mode, addr_mode, addressing_mode;
  305.     int        adj, b, off, type, loc, opkind, value;
  306.     extern    int opdesc_a_mode, opdesc_d_mode;
  307.     Explicit_ref    eref;
  308.     Tuple    labtup, eqtup, newtup, patch_tup;
  309.     Fortup    ft1, ft2;
  310.     int        code_start;
  311.  
  312. #ifdef MACHINE_CODE
  313.     if (list_code) { /* initialize G_s for trace output */
  314.         G_s[0] = '\0';
  315.         obj_name = (Symbol) 0; /* set nonzero if symbol for trace output*/
  316.     }
  317. #endif
  318.     /* label handling */
  319.     code_start = PC();
  320.     code    = op->op_code;
  321.     opkind = op->op_kind;
  322.     type = op->op_type;
  323.     if (code == I_LABEL) {
  324.         lab_name = op->op_arg.arg_sym;
  325. #ifdef MACHINE_CODE
  326.         if (list_code) {
  327.             /*TO_GEN(pretty_addr + ' '*12 + lab_name + ':');*/
  328.             pretty_addr(code_start);
  329.             if (ORIG_NAME(lab_name) != (char *)0) {
  330.                 sprintf(G_END, " s%du%d %s:",
  331.                   S_SEQ(lab_name), S_UNIT(lab_name), ORIG_NAME(lab_name));
  332.             }
  333.             else {
  334.                 sprintf(G_END, " s%du%d:", S_SEQ(lab_name), S_UNIT(lab_name));
  335.             }
  336.             to_gen(G_s);
  337.         }
  338. #endif
  339.         /* try labtup code TBSL 7-16-85*/
  340.         labtup = labelmap_get(lab_name);
  341.         eqtup = tup_copy((Tuple) labtup[LABEL_EQUAL]);
  342.         eqtup= tup_with(eqtup, (char *) lab_name);
  343.         FORTUP(new_lab = (Symbol), eqtup, ft1);
  344.             /*loop forall new_lab in (EQUAL(lab_name)?{}) with lab_name do*/
  345.             newtup = labelmap_get(new_lab);
  346.             newtup[LABEL_POSITION] = (char *) PC();
  347.             patch_tup = (Tuple) labtup[LABEL_PATCHES];
  348.             FORTUP(loc = (unsigned int), patch_tup, ft2);
  349.                 /*loop forall loc in (PATCHES(new_lab)?{}) do*/
  350.                 patch_code((unsigned) loc, (unsigned) PC());
  351.             ENDFORTUP(ft2);
  352.         ENDFORTUP(ft1);
  353.         /* end TBSL that am trying 7-16-85 */
  354.         return;
  355.     }
  356.     else if (code == I_EQUAL) {
  357.         /* I_EQUAL should never be generate by C version */
  358.         chaos("I_EQUAL opcode encountered");
  359.     }
  360.     else if (code == I_END) {
  361.         return;
  362.     }
  363.  
  364.     NB_INSTRUCTIONS +=1;
  365.  
  366.     /* compute actual instructions */
  367.     opdesc(code);
  368.     data_mode = opdesc_d_mode;
  369.     addressing_mode = opdesc_a_mode;
  370.     switch (data_mode) {
  371.     case(D_NONE):
  372.         adj = 0;
  373.         if (code == I_STMT) opkind = mu_word; 
  374.         else opkind = mu_byte;
  375.         break;
  376.  
  377.     case(D_ALL):
  378.         adj = adjust(opkind);
  379.         break;
  380.  
  381.     case(D_INT):
  382.         adj = int_adjust(opkind);
  383.         break;
  384.  
  385.     case(D_FIX):
  386.         adj = fix_adjust(opkind);
  387.         break;
  388.  
  389.     case(D_FLOAT):
  390.         adj = float_adjust(opkind);
  391.         break;
  392.  
  393.     case(D_PSEUDO):
  394.         adj = 0;
  395.     }
  396.  
  397.     if (code == I_DATA || code == I_CASE_TABLE) {
  398.         /* Note that I_CASE_TABLE calls generated as gen_ks so that value
  399.          * below corresponds to k part, location to s part.   ds 7-5-85
  400.          */
  401.         if (list_code) {
  402.             pretty_addr(code_start);
  403.             sprintf(G_END, " [");
  404.         }
  405.         /* pseudo instructions */
  406.         if (code == I_DATA) { /* argument is integer */
  407.             asm_int(op->op_arg.arg_int);
  408.         }
  409.         else {  /* I_CASE_TABLE */
  410.             value = opkind;
  411.             lab_name = op->op_arg.arg_sym;
  412.             labtup = labelmap_get(lab_name);
  413.             loc = (int)labtup[LABEL_POSITION];
  414.             if (loc == 0) { /* 0 indicates not yet defined */
  415.                 patch_tup = (Tuple)labtup[LABEL_PATCHES];
  416.                 /*PATCHES(location) = (PATCHES(location)?{}) with PC;*/
  417.                 labtup[LABEL_PATCHES] = (char *) tup_with(
  418.                   (Tuple) labtup[LABEL_PATCHES], (char *) (PC()+sizeof(int)-1));
  419.                 loc = 0;
  420.             }
  421.             /*instruction = [value, loc];*/
  422.             asm_int(value);
  423.             asm_int(loc);
  424.         }
  425.     }
  426.     else {
  427. #ifdef MACHINE_CODE
  428.         if (list_code) {
  429.             pretty_addr(code_start);
  430.             sprintf(G_END, " [");
  431.             /*inst_string = pretty_map(code)+' ';*/
  432.         }
  433. #endif
  434.         switch ( addressing_mode) {
  435.  
  436.         case(A_NONE):
  437.             asm_byte(code+adj);
  438.             break;
  439.  
  440.         case(A_BOTH):
  441.             adj = 2*adj;
  442.             if (type == OP_REF) { /* if explicit ref */
  443.                 eref = op->op_arg.arg_ref;
  444.                 addr_mode   = A_GLOBAL;
  445.                 asm_byte(code+adj);
  446.                 asm_seg(eref->explicit_ref_seg);
  447.                 asm_off(eref->explicit_ref_off);
  448.                 /*obj_name    = str obj_name;*/
  449.             }
  450.             else {
  451. #ifdef MACHINE_CODE
  452.                 if (list_code) obj_name = op->op_arg.arg_sym;
  453. #endif
  454.                 reference_of(op->op_arg.arg_sym);
  455.                 if (REFERENCE_SEGMENT == 0 ) {
  456.                     addr_mode   = A_LOCAL;
  457.                     /*instruction = [code+adj+1, REFERENCE_OFFSET];*/
  458.                     asm_byte(code+adj+1);
  459.                     asm_off(off = (int) REFERENCE_OFFSET);
  460.                 }
  461.                 else {
  462.                     addr_mode   = A_GLOBAL;
  463.                     asm_byte(code+adj);
  464.                     asm_seg(REFERENCE_SEGMENT);
  465.                     asm_off((int) REFERENCE_OFFSET);
  466.                     /*instruction = [code+adj, b, off];*/
  467.                 }
  468.             }
  469.             break;
  470.  
  471.         case(A_LOCAL):
  472.             if (type == OP_REF) { /* if explicit ref */
  473.                 eref = op->op_arg.arg_ref;
  474.                 off = eref->explicit_ref_off;
  475.             }
  476.             else {
  477. #ifdef MACHINE_CODE
  478.                 if (list_code) obj_name = op->op_arg.arg_sym;
  479. #endif
  480.                 reference_of(op->op_arg.arg_sym);
  481.                 off = REFERENCE_OFFSET;
  482.             }
  483.             addr_mode   = A_LOCAL;
  484.             asm_byte(code+adj);
  485.             /*instruction = [code+adj, off];*/
  486.             asm_off(off);
  487.             break;
  488.  
  489.         case(A_GLOBAL):
  490.             if (type == OP_REF) { /* if explicit */
  491.                 eref = op->op_arg.arg_ref;
  492.                 b = eref->explicit_ref_seg;
  493.                 off = eref->explicit_ref_off;
  494.             }
  495.             else {
  496. #ifdef MACHINE_CODE
  497.                 if (list_code) obj_name = op->op_arg.arg_sym;
  498. #endif
  499.                 reference_of(op->op_arg.arg_sym);
  500.                 b = REFERENCE_SEGMENT;
  501.                 off = REFERENCE_OFFSET;
  502.             }
  503.             addr_mode   = A_GLOBAL;
  504.             /*instruction = [code+adj, b, off];*/
  505.             asm_byte(code+adj);
  506.             asm_seg(b);
  507.             asm_off(off);
  508.             break;
  509.  
  510.         case(A_CODE):
  511.             labtup = labelmap_get(op->op_arg.arg_sym);
  512.             /* arg corresponds to SETL location*/
  513.             loc = (int) labtup[LABEL_POSITION];
  514.             if (loc == 0) {
  515.                 /*PATCHES(location) = (PATCHES(location)?{}) with PC;*/
  516.                 labtup[LABEL_PATCHES] = (char *) tup_with( (Tuple)
  517.                   labtup[LABEL_PATCHES], (char *)PC());
  518.                 loc= 0;
  519.             }
  520.             /*instruction = [code+adj, loc];*/
  521.             asm_byte(code+adj);
  522.             asm_off(loc);
  523.             break;
  524.  
  525.         case(A_PREDEF):
  526.             asm_byte(code);
  527.             asm_byte(op->op_arg.arg_int);
  528.             break;
  529.  
  530.         case(A_EXCEPTION):
  531.             /* The argument is a symbol from which we need to get the
  532.              * exception number
  533.              */
  534.             /*instruction = [code, EXCEPTION_SLOTS(obj_name fromb param)];*/
  535.             asm_byte(code);
  536.             obj_name = op->op_arg.arg_sym;
  537.             asm_exception(obj_name);
  538.             break;
  539.  
  540.         case(A_IMM):
  541.             asm_byte(code+adj);
  542.             if (type == OP_INT) { /* handle integer immediate values */
  543.                 if(code == I_TERMINATE || code == I_END_ACTIVATION) {
  544.                     asm_byte(op->op_arg.arg_int);
  545.                 }
  546.                 else {
  547.                     asm_int(op->op_arg.arg_int);
  548.                 }
  549.             }
  550.             else if  (type == OP_FIX) {
  551.                 asm_fix(op->op_arg.arg_fix);
  552.             }
  553.             else if (type == OP_FLT) {
  554.                 asm_flt(op->op_arg.arg_flt);
  555.             }
  556.             else {
  557. #ifdef DEBUG
  558.                 zpop(op);
  559. #endif
  560.                 chaos("gen.c A_IMM not supported for this case");
  561.             }
  562.             break;
  563.  
  564.         case(A_ATTR):
  565.             /* k field gives attribute number, arg field is integer constant */
  566.             asm_byte(code);
  567.             asm_byte(op->op_kind);
  568.             if (op->op_kind == ATTR_O_LENGTH || op->op_kind == ATTR_O_FIRST
  569.               || op->op_kind == ATTR_O_LAST || op->op_kind == ATTR_O_RANGE) {
  570.                 asm_int(op->op_arg.arg_int);
  571.             }
  572.         }
  573.     }
  574. #ifdef MACHINE_CODE
  575.     /* generating optional print-out */
  576.     if (list_code) {
  577.         sprintf(G_END, " ]");
  578.         {
  579.             int i, n;
  580. #define I_MARGIN 27
  581.             n =  I_MARGIN - strlen(G_s);/*pad count */
  582.             if (n > 0) {
  583.                 for (i = strlen(G_s); i<I_MARGIN; i++) { /* pad out string */
  584.                     G_s[i] = ' ';
  585.                 }
  586.                 G_s[I_MARGIN] = '\0';
  587.             }
  588.         }
  589.         sprintf(G_END, "%s ", opdesc_name);
  590.         switch (data_mode) {
  591.  
  592.         case(D_NONE):
  593.             break;
  594.  
  595.         case(D_ALL): 
  596.         case(D_INT): 
  597.         case(D_FIX):
  598.             /*inst_string += kind+' ';*/
  599.             sprintf(G_END, "%s ", g_kind(opkind));
  600.             break;
  601.  
  602.         case(D_FLOAT):
  603.             if (opkind == mu_xlng) {
  604.                 /*inst_string += kind+' ';*/
  605.                 sprintf(G_END, "xlng ");
  606.             }
  607.             break;
  608.  
  609.         case(D_PSEUDO):
  610.             break;
  611.         }
  612.  
  613.         if (code == I_DATA || code == I_CASE_TABLE) {
  614.             /* pseudo instructions */
  615.             if (code == I_DATA) {
  616.                 /*inst_string += str instruction(1);*/
  617.                 sprintf(G_END, "%d", op->op_arg.arg_int);
  618.             }
  619.             else {  /* I_CASE_TABLE */
  620.                 /*inst_string = '['+str(value)+', '+location+']';*/
  621.                 sprintf(G_END," %d  %s ", value, op->op_arg.arg_sym->orig_name);
  622.             }
  623.         }
  624.         else {
  625.             switch (addressing_mode) {
  626.  
  627.             case(A_NONE):
  628.                 break;
  629.  
  630.             case(A_BOTH): 
  631.             case(A_LOCAL): 
  632.             case(A_GLOBAL):
  633.                 if (addr_mode == A_LOCAL) {
  634.                     /* SETL 'obj_name' corresonds to C 'arg' (check this TBSL)*/
  635.                     if (tup_mem((char *) obj_name , PARAMETER_SET)) {
  636.                         /*inst_string += 'param ';*/
  637.                         sprintf(G_END, "param");
  638.                     }
  639.                     else if (off < 0 ) {
  640.                         /*inst_string += 'local ';*/
  641.                         sprintf(G_END, "local ");
  642.                     }
  643.                     else {
  644.                         /*inst_string += 'relay ';*/
  645.                         sprintf(G_END, "relay ");
  646.                     }
  647.                 }
  648.                 /*inst_string += obj_name;*/
  649.                 /* TBSL: get obj_name right in instruction dump*/
  650.                 if (obj_name != (Symbol)0) {
  651.                     sprintf(G_END, " s%du%d %s", S_SEQ(obj_name),
  652.                       S_UNIT(obj_name), ORIG_NAME(obj_name));
  653.                     /*sprintf(G_END, " OBJ_NAME ");*/
  654.                 }
  655.                 break;
  656.  
  657.             case(A_CODE):
  658.                 /*inst_string += location;*/
  659.                 /* TBSL: get "location" right in instruction dump */
  660.                 obj_name = op->op_arg.arg_sym;
  661.                 if (ORIG_NAME(obj_name) != (char *)0) {
  662.                     sprintf(G_END, " s%du%d %s", S_SEQ(obj_name),
  663.                       S_UNIT(obj_name), ORIG_NAME(obj_name));
  664.                 }
  665.                 else {
  666.                     sprintf(G_END," s%du%d", S_SEQ(obj_name), S_UNIT(obj_name));
  667.                 }
  668.                 break;
  669.  
  670.             case(A_PREDEF):
  671.                 sprintf(G_END, " %s", predef_name(op->op_arg.arg_int));
  672.                 break;
  673.  
  674.             case(A_EXCEPTION):
  675.                 /*inst_string += obj_name;*/
  676.                 sprintf(G_END, " s%du%d %s", S_SEQ(obj_name),
  677.                   S_UNIT(obj_name), ORIG_NAME(obj_name));
  678.                 break;
  679.  
  680.             case(A_IMM):
  681.                 /*inst_string += str(value);*/
  682.                 if (type == OP_INT)
  683.                     sprintf(G_END, " %d ", op->op_arg.arg_int);
  684.                 break;
  685.  
  686.             case(A_ATTR):
  687.                 /*inst_string += attribute_map(attr_code) +' '+ value;*/
  688.                 /* cannot use opkind below - it has been altered  ds 7-21-85*/
  689.                 sprintf(G_END, "%s %d",
  690.                   attribute_str(op->op_kind), op->op_kind);
  691.                 break;
  692.             }
  693.         }
  694.         /*inst_string += '  -- '+ (comment fromb param);*/
  695.         if (op->op_com != (char *)0) {
  696.             sprintf(G_END, "-- %s", op->op_com);
  697.         }
  698.  
  699.         /*  Formatting the output */
  700.         /* TO_GEN(pretty_addr + ' ' + RPAD(str(instruction), 14) + 
  701.          * ' ' * 4 + inst_string);*/
  702.         to_gen(G_s);
  703.     }
  704. #endif
  705. }
  706.  
  707. /* adjust, int_adjust, etc. correspond to constant maps at start
  708.  * of assemble() in SETL version.
  709.  */
  710.  
  711. static char *g_kind(int k)                                        /*;g_kind*/
  712. {
  713.     /* convert 'kind' code to string identifying operation type */
  714.     if (k == mu_byte) return "word";
  715.     else if (k == mu_word) return "word";
  716.     else if (k == mu_addr) return "addr";
  717.     else if (k == mu_long) return "long";
  718.     else if (k == mu_dble) return "dble";
  719.     else if (k == mu_xlng) return "xlng";
  720.     else return "UNKN";
  721. }
  722.  
  723. static int adjust(int k)                                        /*;adjust*/
  724. {
  725.     /* For now, convert byte ops to word form */
  726.     if (k == mu_byte) return 1;
  727.     else if (k == mu_word) return 1;
  728.     else if (k == mu_addr) return 2;
  729.     else if (k == mu_long) return 3;
  730.     else if (k == mu_dble) return 4;
  731.     else if (k == mu_xlng) return 5;
  732.     else return 0;
  733. }
  734.  
  735. static int int_adjust(int k)                                /*;int_adjust*/
  736. {
  737.     /* For now, convert byte ops to word form */
  738.     if (k == mu_byte) return 1;
  739.     else if (k == mu_word) return 1;
  740.     else if (k == mu_long) return 2;
  741.     else return 0;
  742. }
  743.  
  744. static int fix_adjust(int k)                                /*;fix_adjust*/
  745. {
  746.     /* For now, convert byte ops to word form */
  747.     if (k == mu_byte) return 1;
  748.     else if (k == mu_word) return 1;
  749.     else if (k == mu_long) return 2;
  750.     else if (k == mu_xlng) return 3;
  751.     else return 0;
  752. }
  753.  
  754. static int float_adjust(int k)                                /*;float_adjust*/
  755. {
  756.     if (k == mu_long) return 0;
  757.     else if (k == mu_xlng) return 1;
  758.     else return 0;
  759. }
  760.  
  761. static void pretty_addr(int start)                            /*;pretty_addr*/
  762. {
  763.     /* String representing an address in the listing */
  764.     /*(LPAD(str CURRENT_CODE_SEGMENT, 3) +' '+ LPAD(str PC, 4))*/
  765.     sprintf(G_END, " %2d %5d ", CURRENT_CODE_SEGMENT, start);
  766. }
  767.  
  768. Explicit_ref explicit_ref_new(int seg, int off)            /*;explicit_ref_new*/
  769. {
  770.     Explicit_ref    eref;
  771.     eref = (Explicit_ref) emalloct(sizeof(Explicit_ref_s), "explicit-ref");
  772.     eref->explicit_ref_seg = seg;
  773.     eref->explicit_ref_off = off;
  774.     return eref;
  775. }
  776.  
  777. /* asm procedures to generate actual instructions */
  778.  
  779. static void asm_exception(Symbol sym)                    /*;asm_exception*/
  780. {
  781.     /* This procedure is called to assemble an exception name by looking up
  782.      * the corresponding exception value in EXCEPTION_SLOTS, failing if no
  783.      * value assigned.
  784.      */
  785.  
  786.     int    i, n, en, exists;
  787.     Slot slot;
  788.  
  789.     n = tup_size(EXCEPTION_SLOTS);
  790.     exists = FALSE;
  791.     for (i = 1; i <= n; i++) {
  792.         slot = (Slot) EXCEPTION_SLOTS[i];
  793.         if (slot->slot_seq == S_SEQ(sym) && slot->slot_unit == S_UNIT(sym)) {
  794.             exists  = TRUE;
  795.             en = slot->slot_number;
  796.             break;
  797.         }
  798.     }
  799.     if (exists) {
  800.         /* might want byte not word here, but use word as first cut */
  801.         asm_int(en);
  802.     }
  803.     else {
  804.         chaos("gen.c: cannot find exception value ");
  805.     }
  806. }
  807.  
  808. static void asm_byte(int i)                                        /*;asm_byte*/
  809. {
  810.     /* add byte to current instruction */
  811.     G_int(i);
  812.     segment_put_byte(CODE_SEGMENT, i);
  813. }
  814.  
  815. static void asm_int(int i)                                        /*;asm_int*/
  816. {
  817.     /* add int to current instruction */
  818.     G_int(i);
  819.     segment_put_int(CODE_SEGMENT, i);
  820. }
  821.  
  822. static void asm_fix(long i)                                        /*;asm_fix*/
  823. {
  824.     /* add fix (long) to current instruction */
  825.     G_fix(i);
  826.     segment_put_long(CODE_SEGMENT, i);
  827. }
  828.  
  829. static void asm_flt(float i)                                    /*;asm_flt*/
  830. {
  831.     /* add flt (float) to current instruction */
  832.     G_flt(i);
  833.     segment_put_real(CODE_SEGMENT, i);
  834. }
  835.  
  836. static void asm_seg(int i)                                        /*;asm_seg*/
  837. {
  838.     /* add segment number to current instruction */
  839.     G_int(i);
  840.     segment_put_byte(CODE_SEGMENT, i);
  841. }
  842.  
  843. static void asm_off(int i)                                        /*;asm_off*/
  844. {
  845.     /* add offset (16 bits) to current instruction */
  846.     G_int(i);
  847.     segment_put_word(CODE_SEGMENT,  i);
  848. }
  849.  
  850. static void G_int(int i)                                        /*;G_int*/
  851. {
  852. #ifdef MACHINE_CODE
  853.     if (list_code) sprintf(G_END, " %d", i);
  854. #endif
  855. }
  856.  
  857. static void G_fix(long i)                                        /*;G_fix*/
  858. {
  859. #ifdef MACHINE_CODE
  860.     if (list_code) sprintf(G_END, " %ld", i);
  861. #endif
  862. }
  863.  
  864. static void G_flt(float f)                                        /*;G_flt*/
  865. {
  866. #ifdef MACHINE_CODE
  867.     if (list_code) sprintf(G_END, " %e", f);
  868. #endif
  869. }
  870.  
  871. #ifdef DEBUG
  872. static void zpop(Op op)                                            /*;zpop*/
  873. {
  874.     int    code;
  875.     int        type, opkind;
  876.     extern    int opdesc_a_mode, opdesc_d_mode;
  877.     extern    char *opdesc_name;
  878.  
  879.     code    = op->op_code; 
  880.     opkind = op->op_kind;
  881.     type = op->op_type;
  882.  
  883.  
  884.     printf("op code %d %s kind %d type(%d) ", code, opdesc_name, opkind, type);
  885.     if (type == OP_FLT) printf("flt");
  886.     else if (type == OP_FIX) printf("fix");
  887.     else if (type == OP_INT) printf("int");
  888.     else if (type == OP_REF) printf("ref");
  889.     else if (type == OP_SYM) printf("sym");
  890.     printf("\n");
  891. }
  892. #endif
  893.  
  894. /* print_ref_map, defined in gmisc in SETL version, is defined here
  895.  * in C version, as it needs macros required to support GEN_flag option.
  896.  */
  897. /* On input-output */
  898. /* In SETL this is used only to print the local reference map, so we
  899.  * dispense with the argument here, LOCAL_REFERENCE_MAP being assumed
  900.  */
  901.  
  902. void print_ref_map_local()                            /*;print_ref_map_local*/
  903. {
  904. #ifdef MACHINE_CODE
  905.     int    i, off, n;
  906.     Symbol    sym;
  907.     char     *name, *nstr;
  908.     if (!list_code) return;
  909.     to_gen(" ");
  910.     n = tup_size(LOCAL_REFERENCE_MAP);
  911.     for (i = 1; i <= n; i += 2) {
  912.         sym = (Symbol) LOCAL_REFERENCE_MAP[i];
  913.         off = (int) LOCAL_REFERENCE_MAP[i+1];
  914.         if (ORIG_NAME(sym) != (char *)0) {
  915.             name = ORIG_NAME(sym);
  916.         }
  917.         else {
  918.             name = "";
  919.         }
  920.         if (NATURE(sym) == na_void) {
  921.             nstr = "internal";
  922.         }
  923.         else {
  924.             nstr = nature_str(NATURE(sym));
  925.         }
  926.         sprintf(G_s, "         %5d %s  %s", off, nstr, name);
  927.         /*LPAD(name, 25)+'  =>  '+RPAD(str(ref), 12)+NATURE(name)?"internal");*/
  928.         to_gen(G_s);
  929.     }
  930.     to_gen(" ");
  931. #endif
  932. }
  933.  
  934. void print_ref_map_global()                            /*;print_ref_map_global*/
  935. {
  936. #ifdef MACHINE_CODE
  937.     int    i, off, n, seg;
  938.     Symbol    sym;
  939.     char     *name, *nstr;
  940.     Tuple    tup;
  941.     Gref    gref;
  942.     if (!list_code) return;
  943.     to_gen(" ");
  944.     to_gen("-------- Sorted by name ");
  945.     tup = tup_copy(global_reference_tuple);
  946.     gref_sort(tup, 0); /* 0 for name sort*/
  947.     n = tup_size(tup);
  948.     for (i = 1; i <= n; i ++) {
  949.         gref = (Gref) tup[i];
  950.         sym = gref->gref_sym;
  951.         seg = gref->gref_seg;
  952.         off = gref->gref_off;
  953.         if (ORIG_NAME(sym) != (char *)0) {
  954.             name = ORIG_NAME(sym);
  955.         }
  956.         else {
  957.             name = "";
  958.         }
  959.         if (NATURE(sym) == na_void) {
  960.             nstr = "internal";
  961.         }
  962.         else {
  963.             nstr = nature_str(NATURE(sym));
  964.         }
  965.         sprintf(G_s, "\t%s %3d %5d %s  s%du%d", name, seg, off, nstr,
  966.           S_SEQ(sym), S_UNIT(sym));
  967.         /*LPAD(name, 25)+'  =>  '+RPAD(str(ref), 12)+NATURE(name)?"internal");*/
  968.         to_gen(G_s);
  969.     }
  970.     gref_sort(tup, 1); /* 1 for value sort */
  971.     to_gen("-------- Sorted by value ");
  972.     for (i = 1; i <= n; i++) {
  973.         gref = (Gref) tup[i];
  974.         sym = gref->gref_sym;
  975.         seg = gref->gref_seg;
  976.         off = gref->gref_off;
  977.         if (ORIG_NAME(sym) != (char *)0) {
  978.             name = ORIG_NAME(sym);
  979.         }
  980.         else {
  981.             name = "";
  982.         }
  983.         if (NATURE(sym) == na_void) {
  984.             nstr = "internal";
  985.         }
  986.         else {
  987.             nstr = nature_str(NATURE(sym));
  988.         }
  989.         sprintf(G_s, "\t%3d %5d %s %s s%du%d", seg, off, name, nstr,
  990.           S_SEQ(sym), S_UNIT(sym));
  991.         /*LPAD(name, 25)+'  =>  '+RPAD(str(ref), 12)+NATURE(name)?"internal");*/
  992.         to_gen(G_s);
  993.     }
  994.     to_gen(" ");
  995.     tup_free(tup);
  996. #endif
  997. }
  998.  
  999. static void gref_sort(Tuple tup, int type)                        /*;gref_sort*/
  1000. {
  1001.     int        n;
  1002.     n = tup_size(tup); /* three entries per reference*/
  1003.     if (type == 0)
  1004.         qsort((char *) &tup[1], n, sizeof(char *),
  1005.          (int(*)(const void *, const void *)) gref_compare_name);
  1006.     else
  1007.         qsort((char *) &tup[1], n,  sizeof(char *), 
  1008.          (int(*)(const void *, const void *))gref_compare_address);
  1009. }
  1010.  
  1011. static int gref_compare_name(Gref *pref1, Gref *pref2)    /*;gref_compare_name*/
  1012. {
  1013.     Gref    ref1, ref2;
  1014.     Symbol    sym1, sym2;
  1015.     char    *s1, *s2;
  1016.     ref1 = *pref1; 
  1017.     ref2 = *pref2;
  1018.     sym1 = ref1->gref_sym; 
  1019.     sym2 = ref2->gref_sym;
  1020.     if (ORIG_NAME(sym1) != (char *)0) s1 = ORIG_NAME(sym1);
  1021.     else s1 = "";
  1022.     if (ORIG_NAME(sym2) != (char *)0) s2 = ORIG_NAME(sym2);
  1023.     else s2 = "";
  1024.     return strcmp(s1, s2);
  1025. }
  1026.  
  1027. static int gref_compare_address(Gref *pref1, Gref *pref2)
  1028.                                                     /*;gref_compare_address*/
  1029. {
  1030.     Gref    ref1, ref2;
  1031.  
  1032.     int seg1, off1, seg2, off2;
  1033.     ref1 = *pref1, ref2 = *pref2;
  1034.     seg1 = ref1->gref_seg; 
  1035.     seg2 = ref2->gref_seg;
  1036.     off1 = ref1->gref_off; 
  1037.     off2 = ref2->gref_off;
  1038.     if (seg1<seg2) return -1;
  1039.     else if (seg1>seg2) return 1;
  1040.     else if (off1<off2) return -1;
  1041.     else if (off1 == off2) return 0;
  1042.     else return 1;
  1043. }
  1044.  
  1045. static char *gs_end()                                    /*;gs_end*/
  1046. {
  1047.     return (G_s + strlen(G_s));
  1048. }
  1049.